home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / picklst.exe / OBJECTS1.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-26  |  3KB  |  142 lines
  1. unit Objects1;
  2.  
  3. {Provides an error function for stream use.
  4.  Provides tStrObj, a string object with init, done, load and store
  5.  methods for use with collections.
  6. }
  7. {********************************}
  8. {***Programmed by             ***}
  9. {***Blake Watson              ***}
  10. {***CIS number 70303,373      ***}
  11. {********************************}
  12. interface
  13.  
  14. uses Objects;
  15.  
  16. type
  17.    pStrObj = ^TStrObj;
  18.    tstrobj = object(tObject)
  19.          p: pString;
  20.       constructor Init(S: String);
  21.       constructor Load(S: tStream);
  22.       function  GetString: String;
  23.       procedure Store(S: tStream);
  24.       destructor  Done; virtual;
  25.       end;
  26.  
  27.    pStrObjCollection = ^TStrObjCollection;
  28.    tStrObjCollection = object(TCollection)
  29.       function StringAt(I: Integer): string;
  30.       end;
  31.  
  32.    pStrCollection = ^TStrCollection;
  33.    tStrCollection = object(TStringCollection)
  34.       function Compare(Key1, Key2: Pointer): Integer; virtual;
  35.       end;
  36.  
  37.    PNOCollection = ^TNoCollection;
  38.    TNoCollection = object(TCollection)
  39.          ItemSize: word;
  40.       constructor Init(ALimit, ADelta: Integer; Size: Word);
  41.       procedure   FreeItem(Item: Pointer); virtual;
  42.       function    GetItem(var S: TStream): pointer; virtual;
  43.       procedure   PutItem(var S: TStream; Item: Pointer); virtual;
  44.       end;
  45.  
  46. const
  47.  
  48.   RStrObj  : TStreamRec = (
  49.     ObjType: $FFFF;
  50.     VmtLink: Ofs(TypeOf(TStrObj)^);
  51.     Load:    @TStrObj.Load;
  52.     Store:   @TStrObj.Store
  53.   );
  54.  
  55. implementation
  56.  
  57. uses App, MsgBox;
  58.  
  59. function StrFn(A: Longint): string;
  60. var s: string;
  61. begin
  62.    Str(A,S);
  63.    StrFn := s;
  64.    end;
  65.  
  66. procedure Error(var s: tStream); far;
  67. var w: word;
  68. begin
  69.    if StatusLine = Nil then
  70.    begin
  71.       writeln('Stream failure.  Status = ',s.Status,'.  Info = ',s.ErrorInfo,'.');
  72.       halt(1);
  73.       end;
  74.    w := MessageBox('Stream process failed with a Code of '
  75.       +StrFn(s.Status)+' and an Info of '+StrFn(s.ErrorInfo),nil,mfError+mfOKButton);
  76.    s.Reset;
  77.    end;
  78.  
  79. constructor tstrobj.Init;
  80. begin
  81.    p := NewStr(S);
  82.    end;
  83.  
  84. constructor tStrObj.Load;
  85. begin
  86.    P := S.ReadStr;
  87.    end;
  88.  
  89. procedure tStrObj.Store;
  90. begin
  91.    S.WriteStr(P);
  92.    end;
  93.  
  94. destructor tstrobj.Done;
  95. begin
  96.    disposeStr(p);
  97.    tObject.done;
  98.    end;
  99.  
  100. function TStrObj.GetString: String;
  101. begin
  102.    If p = nil then GetString := '' else
  103.    GetString := P^;
  104.    end;
  105.  
  106. constructor TNOCollection.Init;
  107. begin
  108.    TCollection.Init(Alimit, Adelta);
  109.    ItemSize := Size;
  110.    end;
  111.  
  112. procedure TNOCollection.FreeItem;
  113. begin
  114.    Dispose(Item);
  115.    end;
  116.  
  117. function  TNOCollection.GetItem(var S:TStream): pointer;
  118. var P: pointer;
  119. begin
  120.    GetMem(p,ItemSize);
  121.    S.Read(P^,ItemSize);
  122.    GetItem := P;
  123.    end;
  124.  
  125. procedure TNOCollection.PutItem(var S:TStream; Item: Pointer);
  126. begin
  127.    S.Write(Item^,ItemSize);
  128.    end;
  129.  
  130. function  TStrObjCollection.StringAt(I: Integer): string;
  131. begin
  132.    StringAt := PStrObj(At(I))^.GetString;
  133.    end;
  134.  
  135. function  TStrCollection.Compare(Key1, Key2: Pointer): Integer;
  136. begin
  137.    Compare := 1;
  138.    end;
  139.  
  140. begin
  141.    Objects.StreamError := @Error;
  142.    end.